home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software Vault: The Gold Collection
/
Software Vault - The Gold Collection (American Databankers) (1993).ISO
/
cdr48
/
bpl70n12.zip
/
TESTPRGS.ZIP
/
DSIN.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1993-02-14
|
10KB
|
329 lines
PROGRAM DSin; { ported from Fortran original 05-01-92 Norbert Juffa }
{$A+,B-,D-,E+,F-,G-,I-,L-,N-,O-,R-,S-,V-,X-}
USES MachArit, Power;
{
C PROGRAM TO TEST DSIN/DCOS
C
C DATA REQUIRED
C
C NONE
C
C SUBPROGRAMS REQUIRED FROM THIS PACKAGE
C
C MACHAR - AN ENVIRONMENTAL INQUIRY PROGRAM PROVIDING
C INFORMATION ON THE FLOATING-POINT ARITHMETIC
C SYSTEM. NOTE THAT THE CALL TO MACHAR CAN
C BE DELETED PROVIDED THE FOLLOWING FIVE
C PARAMETERS ARE ASSIGNED THE VALUES INDICATED
C
C IBETA - THE RADIX OF THE FLOATING-POINT SYSTEM
C IT - THE NUMBER OF BASE-IBETA DIGITS IN THE
C SIGNIFICAND OF A FLOATING-POINT NUMBER
C MINEXP - THE LARGEST IN MAGNITUDE NEGATIVE
C INTEGER SUCH THAT DFLOAT(IBETA)**MINEXP
C IS A POSITIVE FLOATING-POINT NUMBER
C EPS - THE SMALLEST POSITIVE FLOATING-POINT
C NUMBER SUCH THAT 1.0+EPS .NE. 1.0
C EPSNEG - THE SMALLEST POSITIVE FLOATING-POINT
C NUMBER SUCH THAT 1.0-EPSNEG .NE. 1.0
C
C REN(K) - A FUNCTION SUBPROGRAM RETURNING RANDOM REAL
C NUMBERS UNIFORMLY DISTRIBUTED OVER (0,1)
C
C
C STANDARD FORTRAN SUBPROGRAMS REQUIRED
C
C DABS, DLOG, DMAX1, DCOS, DLOAT, DSIN, DSQRT
C
C
C LATEST REVISION - DECEMBER 6, 1979
C
C AUTHOR - W. J. CODY
C ARGONNE NATIONAL LABORATORY
C
C
}
FUNCTION REN (VAR K: LONGINT): REAL;
{
DOUBLE PRECISION FUNCTION REN(K)
C
C RANDOM NUMBER GENERATOR - BASED ON ALGORITHM 266 BY PIKE AND
C HILL (MODIFIED BY HANSSON), COMMUNICATIONS OF THE ACM,
C VOL. 8, NO. 10, OCTOBER 1965.
C
C THIS SUBPROGRAM IS INTENDED FOR USE ON COMPUTERS WITH
C FIXED POINT WORDLENGTH OF AT LEAST 29 BITS. IT IS
C BEST IF THE FLOATING POINT SIGNIFICAND HAS AT MOST
C 29 BITS.
C
}
VAR J: LONGINT;
CONST IY: LONGINT = 100001;
BEGIN
J := K;
IY := IY * 125;
IY := IY - (IY DIV 2796203) * 2796203;
REN:= 1.0 * (IY) / 2796203.0e0 * (1.0e0 + 1.0e-6 + 1.0e-12);
END;
FUNCTION MAX1 (A, B:REAL): REAL;
BEGIN
IF A > B THEN
MAX1 := A
ELSE
MAX1 := B;
END;
VAR I,IBETA,IEXP,IOUT,IRND,IT,I1,J, K1,K2,
K3,MACHEP,MAXEXP,MINEXP,N,NEGEP,NGRD: LONGINT;
A,AIT,ALBETA,B,BETA,C,DEL,EPS,EPSNEG,HALF,ONE,
T,THREE,BETAP,TEMP,EXPON,R6,R7,TENTH,W,X,XL,PI,
XMAX,XMIN,XN,X1,Y,Z,ZERO,ZZ,THREEFOURTH,FOUR,SIX: REAL;
LABEL 100, 110, 120, 150, 160, 210, 220, 230, 240, 300;
BEGIN
N := 1000000; { number of trials }
MACHAR (IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
EPS,EPSNEG,XMIN,XMAX);
PRINTPARAM (IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,MAXEXP,
EPS,EPSNEG,XMIN,XMAX);
BETA := IBETA;
ALBETA := LN (BETA);
AIT := IT;
ZERO := 0;
ONE := 1;
THREE := 3;
FOUR := 4;
SIX := 6;
HALF := 0.5;
THREEFOURTH:= 0.75;
PI := 3.14159265358979323846264338327950288;
A := ZERO;
B := HALF*PI;
C := B;
XN := N;
I1 := 0;
{-----------------------------------------------------------------}
{ RANDOM ARGUMENT ACCURACY TESTS }
{-----------------------------------------------------------------}
FOR J := 1 TO 3 DO BEGIN
K1 := 0;
K3 := 0;
X1 := ZERO;
R6 := ZERO;
R7 := ZERO;
DEL:= (B - A) / XN;
XL := A;
FOR I := 1 TO N DO BEGIN
X := DEL * REN (I1) + XL;
Y := X / THREE;
Y := (X + Y);
Y := Y - X;
X := THREE * Y;
IF J = 3 THEN
GOTO 100;
Z := SIN (X);
ZZ:= SIN (Y);
W := ONE;
IF Z <> ZERO THEN BEGIN
TEMP := FOUR * ZZ * ZZ;
TEMP := THREE - TEMP;
TEMP := ZZ * TEMP;
TEMP := Z - TEMP;
W := TEMP / Z;
END;
GOTO 110;
100: Z := COS (X);
ZZ := COS (Y);
W := ONE;
IF Z <> ZERO THEN BEGIN
TEMP := FOUR * ZZ * ZZ;
TEMP := THREE - TEMP;
TEMP := ZZ * TEMP;
TEMP := Z + TEMP;
W := TEMP / Z;
END;
110: IF W > ZERO THEN
K1 := K1 + 1;
IF W < ZERO THEN
K3 := K3 + 1;
W := ABS(W);
IF W <= R6 THEN
GOTO 120;
R6 := W;
X1 := X;
120: R7 := R7 + W * W;
XL := XL + DEL;
END;
K2 := N - K3 - K1;
R7 := SQRT (R7/XN);
IF J = 3 THEN
GOTO 210;
WRITELN;
WRITELN;
WRITELN ('TEST OF SIN(X) VS 3*SIN(X/3)-4*SIN(X/3)**3');
WRITELN;
WRITELN (N, ' RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL');
WRITELN ('(', A, ',', B, ')');
WRITELN;
inline ($fa/$fb);
WRITELN ('SIN (X) WAS LARGER', K1:6, ' TIMES');
WRITELN (' AGREED', K2:6, ' TIMES');
WRITELN (' AND WAS SMALLER', K3:6, ' TIMES');
GOTO 220;
210: WRITELN;
WRITELN;
WRITELN ('TEST OF COS(X) VS 4*COS(X/3)**3-3*COS(X/3)');
WRITELN;
WRITELN (N, ' RANDOM ARGUMENTS WERE TESTED FROM THE INTERVAL');
WRITELN ('(', A, ',', B, ')');
WRITELN;
WRITELN ('COS (X) WAS LARGER', K1:6, ' TIMES');
WRITELN (' AGREED', K2:6, ' TIMES');
WRITELN (' AND WAS SMALLER', K3:6, ' TIMES');
220: WRITELN;
WRITELN ('THERE ARE ', IT, ' BASE ', IBETA,
' SIGNIFICANT DIGITS IN A FLOATING-POINT NUMBER');
WRITELN;
W := -999.0;
IF R6 <> ZERO THEN
W := LN (ABS(R6))/ALBETA;
WRITELN ('THE MAXIMUM RELATIVE ERROR OF ', R6:12,
' = ', IBETA, ' **', W:7:2);
WRITELN ('OCCURED FOR X = ', X1);
W := MAX1 (AIT+W, ZERO);
WRITELN;
WRITELN ('THE ESTIMATED LOSS OF BASE ', IBETA,
' SIGNIFICANT DIGITS IS ', W:7:2);
W := -999.0;
IF R7 <> ZERO THEN
W := LN (ABS(R7))/ALBETA;
WRITELN;
WRITELN ('THE ROOT MEAN SQUARE RELATIVE ERROR WAS', R7:12,
' = ', IBETA, ' **' , W:7:2);
W := MAX1 (AIT+W,ZERO);
WRITELN;
WRITELN ('THE ESTIMATED LOSS OF BASE ', IBETA,
' SIGNIFICANT DIGITS IS ', W:7:2);
A := SIX * PI;
IF J = 2 THEN
A := B + C;
B := A + C;
END;
{-----------------------------------------------------------------}
{ SPECIAL TESTS }
{-----------------------------------------------------------------}
WRITELN;
WRITELN;
WRITELN ('SPECIAL TESTS');
WRITELN;
C := ONE / POW (BETA, (IT/2));
Z := SIN (A+C);
Z := Z - SIN (A-C);
TEMP := C + C;
Z := Z / TEMP;
WRITELN ('IF ',Z:18,' IS NOT ALMOST 1.0, SIN HAS THE WRONG PERIOD.');
WRITELN;
WRITELN;
WRITELN ('THE IDENTITY SIN(-X) = -SIN(X) WILL BE TESTED.');
WRITELN;
WRITELN (' F(X) F(X)+F(-X)');
WRITELN;
FOR I := 1 TO 5 DO BEGIN
X := REN(I1) * A;
Z := SIN(X) + SIN(-X);
WRITELN (X:18, Z:18);
END;
WRITELN;
WRITELN;
WRITELN ('THE IDENTITY SIN(X) = X , X SMALL, WILL BE TESTED.');
WRITELN;
WRITELN (' X X-F(X)');
WRITELN;
BETAP := POW (BETA, IT);
X := REN(I1) / BETAP;
FOR I := 1 TO 5 DO BEGIN
Z := X - SIN(X);
WRITELN (X:18, Z:18);
X := X / BETA;
END;
WRITELN;
WRITELN;
WRITELN ('THE IDENTITY COS(-X) = COS(X) WILL BE TESTED.');
WRITELN;
WRITELN (' X F(X)-F(-X)');
WRITELN;
FOR I := 1 TO 5 DO BEGIN
X := REN (I1) * A;
Z := COS (X) - COS (-X);
WRITELN (X:18, Z:18);
END;
WRITELN;
WRITELN;
WRITELN ('TEST OF UNDERFLOW FOR VERY SMALL ARGUMENT.');
WRITELN;
EXPON := MINEXP * THREEFOURTH;
X := POW (BETA, EXPON);
Y := SIN (X);
WRITELN ('SIN (', X:15, ') = ', Y:15);
WRITELN;
WRITELN ('THE FOLLOWING THREE LINES ILLUSTRATE THE LOSS IN SIGNIFICANCE');
WRITELN ('FOR LARGE ARGUMENTS. THE ARGUMENTS ARE CONSECUTIVE.');
WRITELN;
Z := SQRT (BETAP);
X := Z * (ONE - EPSNEG);
Y := SIN(X);
WRITELN ('SIN (', X:15, ') = ', Y:15);
Y := SIN(Z);
WRITELN ('SIN (', X:15, ') = ', Y:15);
X := Z * (ONE + EPS);
Y := SIN(X);
WRITELN ('SIN (', X:15, ') = ', Y:15);
{-----------------------------------------------------------------}
{ TEST OF ERROR RETURNS }
{-----------------------------------------------------------------}
WRITELN;
WRITELN;
WRITELN ('TEST OF ERROR RETURNS');
WRITELN;
X := BETAP;
WRITELN ('SIN WILL BE CALLED WITH THE ARGUMENT ', X:15);
WRITELN ('THIS SHOULD TRIGGER AN ERROR MESSAGE');
Y := SIN(X);
WRITELN ('SIN RETURNED THE VALUE ', Y:15);
WRITELN;
WRITELN ('THIS CONCLUDES THE TESTS');
END. { DSin }